home *** CD-ROM | disk | FTP | other *** search
/ Komputer for Alle 1999 #5 / 1999 CD 5 (black).iso / Delphi3 / install / data.z / CALENDAR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-05  |  8.2 KB  |  299 lines
  1. unit Calendar;
  2.  
  3. interface
  4.  
  5. uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
  6.   Grids, SysUtils;
  7.  
  8. type
  9.   TDayOfWeek = 0..6;
  10.  
  11.   TCalendar = class(TCustomGrid)
  12.   private
  13.     FDate: TDateTime;
  14.     FMonthOffset: Integer;
  15.     FOnChange: TNotifyEvent;
  16.     FReadOnly: Boolean;
  17.     FStartOfWeek: TDayOfWeek;
  18.     FUpdating: Boolean;
  19.     FUseCurrentDate: Boolean;
  20.     function GetCellText(ACol, ARow: Integer): string;
  21.     function GetDateElement(Index: Integer): Integer;
  22.     procedure SetCalendarDate(Value: TDateTime);
  23.     procedure SetDateElement(Index: Integer; Value: Integer);
  24.     procedure SetStartOfWeek(Value: TDayOfWeek);
  25.     procedure SetUseCurrentDate(Value: Boolean);
  26.     function StoreCalendarDate: Boolean;
  27.   protected
  28.     procedure Change; dynamic;
  29.     procedure ChangeMonth(Delta: Integer);
  30.     procedure Click; override;
  31.     function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
  32.     function DaysThisMonth: Integer; virtual;
  33.     procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
  34.     function IsLeapYear(AYear: Integer): Boolean; virtual;
  35.     function SelectCell(ACol, ARow: Longint): Boolean; override;
  36.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  37.   public
  38.     constructor Create(AOwner: TComponent); override;
  39.     property CalendarDate: TDateTime  read FDate write SetCalendarDate stored StoreCalendarDate;
  40.     property CellText[ACol, ARow: Integer]: string read GetCellText;
  41.     procedure NextMonth;
  42.     procedure NextYear;
  43.     procedure PrevMonth;
  44.     procedure PrevYear;
  45.     procedure UpdateCalendar; virtual;
  46.   published
  47.     property Align;
  48.     property BorderStyle;
  49.     property Color;
  50.     property Ctl3D;
  51.     property Day: Integer index 3  read GetDateElement write SetDateElement stored False;
  52.     property Enabled;
  53.     property Font;
  54.     property GridLineWidth;
  55.     property Month: Integer index 2  read GetDateElement write SetDateElement stored False;
  56.     property ParentColor;
  57.     property ParentFont;
  58.     property ParentShowHint;
  59.     property PopupMenu;
  60.     property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
  61.     property ShowHint;
  62.     property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
  63.     property TabOrder;
  64.     property TabStop;
  65.     property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
  66.     property Visible;
  67.     property Year: Integer index 1  read GetDateElement write SetDateElement stored False;
  68.     property OnClick;
  69.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  70.     property OnDblClick;
  71.     property OnDragDrop;
  72.     property OnDragOver;
  73.     property OnEndDrag;
  74.     property OnEnter;
  75.     property OnExit;
  76.     property OnKeyDown;
  77.     property OnKeyPress;
  78.     property OnKeyUp;
  79.     property OnStartDrag;
  80.   end;
  81.  
  82. implementation
  83.  
  84. constructor TCalendar.Create(AOwner: TComponent);
  85. begin
  86.   inherited Create(AOwner);
  87.   { defaults }
  88.   FUseCurrentDate := True;
  89.   FixedCols := 0;
  90.   FixedRows := 1;
  91.   ColCount := 7;
  92.   RowCount := 7;
  93.   ScrollBars := ssNone;
  94.   Options := Options - [goRangeSelect] + [goDrawFocusSelected];
  95.   FDate := Date;
  96.   UpdateCalendar;
  97. end;
  98.  
  99. procedure TCalendar.Change;
  100. begin
  101.   if Assigned(FOnChange) then FOnChange(Self);
  102. end;
  103.  
  104. procedure TCalendar.Click;
  105. var
  106.   TheCellText: string;
  107. begin
  108.   inherited Click;
  109.   TheCellText := CellText[Col, Row];
  110.   if TheCellText <> '' then Day := StrToInt(TheCellText);
  111. end;
  112.  
  113. function TCalendar.IsLeapYear(AYear: Integer): Boolean;
  114. begin
  115.   Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
  116. end;
  117.  
  118. function TCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
  119. const
  120.   DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  121. begin
  122.   Result := DaysInMonth[AMonth];
  123.   if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
  124. end;
  125.  
  126. function TCalendar.DaysThisMonth: Integer;
  127. begin
  128.   Result := DaysPerMonth(Year, Month);
  129. end;
  130.  
  131. procedure TCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
  132. var
  133.   TheText: string;
  134. begin
  135.   TheText := CellText[ACol, ARow];
  136.   with ARect, Canvas do
  137.     TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
  138.       Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
  139. end;
  140.  
  141. function TCalendar.GetCellText(ACol, ARow: Integer): string;
  142. var
  143.   DayNum: Integer;
  144. begin
  145.   if ARow = 0 then  { day names at tops of columns }
  146.     Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
  147.   else
  148.   begin
  149.     DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
  150.     if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
  151.     else Result := IntToStr(DayNum);
  152.   end;
  153. end;
  154.  
  155. function TCalendar.SelectCell(ACol, ARow: Longint): Boolean;
  156. begin
  157.   if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
  158.     Result := False
  159.   else Result := inherited SelectCell(ACol, ARow);
  160. end;
  161.  
  162. procedure TCalendar.SetCalendarDate(Value: TDateTime);
  163. begin
  164.   FDate := Value;
  165.   UpdateCalendar;
  166.   Change;
  167. end;
  168.  
  169. function TCalendar.StoreCalendarDate: Boolean;
  170. begin
  171.   Result := not FUseCurrentDate;
  172. end;
  173.  
  174. function TCalendar.GetDateElement(Index: Integer): Integer;
  175. var
  176.   AYear, AMonth, ADay: Word;
  177. begin
  178.   DecodeDate(FDate, AYear, AMonth, ADay);
  179.   case Index of
  180.     1: Result := AYear;
  181.     2: Result := AMonth;
  182.     3: Result := ADay;
  183.     else Result := -1;
  184.   end;
  185. end;
  186.  
  187. procedure TCalendar.SetDateElement(Index: Integer; Value: Integer);
  188. var
  189.   AYear, AMonth, ADay: Word;
  190. begin
  191.   if Value > 0 then
  192.   begin
  193.     DecodeDate(FDate, AYear, AMonth, ADay);
  194.     case Index of
  195.       1: if AYear <> Value then AYear := Value else Exit;
  196.       2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
  197.       3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
  198.       else Exit;
  199.     end;
  200.     FDate := EncodeDate(AYear, AMonth, ADay);
  201.     FUseCurrentDate := False;
  202.     UpdateCalendar;
  203.     Change;
  204.   end;
  205. end;
  206.  
  207. procedure TCalendar.SetStartOfWeek(Value: TDayOfWeek);
  208. begin
  209.   if Value <> FStartOfWeek then
  210.   begin
  211.     FStartOfWeek := Value;
  212.     UpdateCalendar;
  213.   end;
  214. end;
  215.  
  216. procedure TCalendar.SetUseCurrentDate(Value: Boolean);
  217. begin
  218.   if Value <> FUseCurrentDate then
  219.   begin
  220.     FUseCurrentDate := Value;
  221.     if Value then
  222.     begin
  223.       FDate := Date; { use the current date, then }
  224.       UpdateCalendar;
  225.     end;
  226.   end;
  227. end;
  228.  
  229. { Given a value of 1 or -1, moves to Next or Prev month accordingly }
  230. procedure TCalendar.ChangeMonth(Delta: Integer);
  231. var
  232.   AYear, AMonth, ADay: Word;
  233.   NewDate: TDateTime;
  234.   CurDay: Integer;
  235. begin
  236.   DecodeDate(FDate, AYear, AMonth, ADay);
  237.   CurDay := ADay;
  238.   if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
  239.   else ADay := 1;
  240.   NewDate := EncodeDate(AYear, AMonth, ADay);
  241.   NewDate := NewDate + Delta;
  242.   DecodeDate(NewDate, AYear, AMonth, ADay);
  243.   if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
  244.   else ADay := DaysPerMonth(AYear, AMonth);
  245.   CalendarDate := EncodeDate(AYear, AMonth, ADay);
  246. end;
  247.  
  248. procedure TCalendar.PrevMonth;
  249. begin
  250.   ChangeMonth(-1);
  251. end;
  252.  
  253. procedure TCalendar.NextMonth;
  254. begin
  255.   ChangeMonth(1);
  256. end;
  257.  
  258. procedure TCalendar.NextYear;
  259. begin
  260.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  261.   Year := Year + 1;
  262. end;
  263.  
  264. procedure TCalendar.PrevYear;
  265. begin
  266.   if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
  267.   Year := Year - 1;
  268. end;
  269.  
  270. procedure TCalendar.UpdateCalendar;
  271. var
  272.   AYear, AMonth, ADay: Word;
  273.   FirstDate: TDateTime;
  274. begin
  275.   FUpdating := True;
  276.   try
  277.     DecodeDate(FDate, AYear, AMonth, ADay);
  278.     FirstDate := EncodeDate(AYear, AMonth, 1);
  279.     FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
  280.     if FMonthOffset = 2 then FMonthOffset := -5;
  281.     MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
  282.       False, False);
  283.     Invalidate;
  284.   finally
  285.     FUpdating := False;
  286.   end;
  287. end;
  288.  
  289. procedure TCalendar.WMSize(var Message: TWMSize);
  290. var
  291.   GridLines: Integer;
  292. begin
  293.   GridLines := 6 * GridLineWidth;
  294.   DefaultColWidth := (Message.Width - GridLines) div 7;
  295.   DefaultRowHeight := (Message.Height - GridLines) div 7;
  296. end;
  297.  
  298. end.
  299.